Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue62/Alfresco/AAHpDbug.pas

Pascal/Delphi Source File | 2000-09-02 | 12.3 KB | 411 lines

{*********************************************************}
{* AAHpDbug                                              *}
{* Copyright (c) Julian M Bucknall 2000                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco: Heap debugger                    *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AAHpDbug;

{WARNING: this unit *must* appear first in your project's uses list.}

interface

implementation

uses
  Windows, // it's OK to use the Windows unit: it allocates no memory
  AANoMem; // this unit implements routines that use no heap memory

type
  PPointerArray = ^TPointerArray;
  TPointerArray =
     array [0..pred(MaxInt div sizeof(pointer))] of pointer;

var
  OrigHeap : TMemoryManager;
  OurHeap  : TMemoryManager;
  LogName  : shortstring;
  GuardSize: integer;
  {list of currently allocated blocks}
  PtrArray : PPointerArray;
  PASize   : integer;
  PACount  : integer;
  {delay queue variables}
  DelaySize  : integer;
  DelayQueue : PPointerArray;
  QHead      : integer;
  QTail      : integer;


{===Sorted array of currently allocated blocks=======================}
procedure AddPointer(P : pointer);
var
  L, R, M : integer;
begin
  if (PACount = PASize) then begin
    inc(PASize, 1024);
    HeapRealloc(GetProcessHeap, 0, PtrArray, PASize * sizeof(pointer));
  end;
  if (PACount = 0) then begin
    PtrArray[0] := P;
    PACount := 1;
  end
  else begin
    L := 0;
    R := pred(PACount);
    while (L <= R) do begin
      M := (L + R) div 2;
      if (longint(P) < longint(PtrArray[M])) then
        R := M - 1
      else
        L := M + 1;
    end;
    if (L < PACount) then
      Move(PtrArray[L], PtrArray[L+1], (PACount-L)*sizeof(pointer));
    PtrArray[L] := P;
    inc(PACount);
  end;
end;
{--------}
function RemovePointer(P : pointer) : boolean;
var
  L, R, M : integer;
begin
  if (PACount = 0) then
    Result := false
  else begin
    L := 0;
    R := pred(PACount);
    while L <= R do begin
      M := (L + R) div 2;
      if (longint(P) < longint(PtrArray[M])) then
        R := M - 1
      else if (longint(P) > longint(PtrArray[M])) then
        L := M + 1
      else begin
        dec(PACount);
        if (M <> PACount) then
          Move(PtrArray[M+1], PtrArray[M], (PACount-M)*sizeof(pointer));
        Result := true;
        Exit;
      end;
    end;
    Result := false;
  end;
end;
{====================================================================}


{===Logging stuff====================================================}
function HeapErrorMsg(aErrorCode : integer) : shortstring;
begin
  case aErrorCode of
     1 : Result := 'operating system returned an error on release';
     2 : Result := 'operating system returned an error on decommit';
     3 : Result := 'list of committed blocks looks bad';
     4,
     5,
     6 : Result := 'filler block is bad';
     7 : Result := 'current allocation zone is bad';
     8 : Result := 'couldn''t initialize';
     9 : Result := 'used block looks bad (invalid pointer? double free?)';
    10 : Result := 'prev block before a used block is bad';
    11 : Result := 'next block after a used block is bad';
    12 : Result := 'free list is bad';
    13 : Result := 'free block is bad';
    14 : Result := 'free list doesn''t correspond to blocks marked free';
    99 : Result := 'invalid pointer: not allocated with GetMem, or already freed';
  else
    Result := 'unknown error message';
  end;
end;
{--------}
procedure WriteLogFreeErr(const aMsg : shortstring);
var
  Log : System.text;
begin
  aaLogOpen(Log, LogName);
  try
    writeln(Log, 'FreeMem error: ', aMsg);
  finally
    aaLogClose(Log);
  end;
end;
{--------}
procedure WriteLogOverwrite(P : pointer; aWhere : integer;
                            aMemory : pointer; aLen : integer);
var
  PAsStr : array [0..9] of char;
  Log    : System.Text;
begin
  aaLogOpen(Log, LogName);
  try
    write(Log, 'Memory overwrite detected with block: ');
    aaPointerAsHexZ(PAsStr, P);
    writeln(Log, PAsStr);
    case aWhere of
      0 : writeln(Log, '...overwrite occurred after the block');
      1 : writeln(Log, '...overwrite occurred before the block');
      2 : writeln(Log, '...overwrite occurred within the block after freeing');
    end;
    if (aWhere = 2) then begin
      writeln(Log, '...memory block contents (', aLen, ' bytes):');
      aaLogWriteBuffer(Log, aMemory, aLen);
    end
    else begin
      writeln(Log, '...guard block contents (', aLen, ' bytes):');
      aaLogWriteBuffer(Log, aMemory, aLen);
    end;
  finally
    aaLogClose(Log);
  end;
end;
{--------}
procedure WriteLogLeaks;
var
  Log : System.text;
  i   : integer;
  P   : pointer;
  Size: integer;
begin
  aaLogOpen(Log, LogName);
  try
    writeln(Log, 'Memory leaks: ', PACount);
    for i := 0 to pred(PACount) do begin
      P := PtrArray[i];
      Size := PInteger(PChar(P) - GuardSize - sizeof(integer))^;
      writeln(Log, '...leaked block ', i, ' contents (', Size, ' bytes):');
      aaLogWriteBuffer(Log, P, Size);
    end;
  finally
    aaLogClose(Log);
  end;
end;
{====================================================================}


{===Guard block code=================================================}
procedure CheckGuardBlocks(P : pointer);
var
  Mem  : PChar;
  Size : integer;
  RoundedSize : integer;
  SecondSize  : integer;
begin
  {get the address of the first guard block, and verify that it hasn't
   been changed by an overwrite}
  Mem := P;
  dec(Mem, GuardSize);
  if not aaCompareMem(Mem, GuardSize, $CC) then
    WriteLogOverwrite(P, 1, Mem, GuardSize);
  {get the size of the user's memory block, and work out the address
   and size of the second guard block; verify that it also hasn't been
   changed}
  dec(Mem, sizeof(integer));
  Size := PInteger(Mem)^;
  inc(Mem, sizeof(integer) + GuardSize + Size);
  RoundedSize := (Size + 3) and $7FFFFFFC;
  SecondSize := GuardSize + (RoundedSize - Size);
  if not aaCompareMem(Mem, SecondSize, $CC) then
    WriteLogOverwrite(P, 0, Mem, GuardSize);
end;
{====================================================================}


{===Replacement memory routines======================================}
function OurGetMem(Size : integer) : pointer;
type
  PInteger = ^integer;
var
  RoundedSize : integer;
begin
  {on a GetMem, we have to add the size of our guard blocks and an
   extra size value to the size to allocate; round up to nearest 4
   bytes}
  RoundedSize := (Size + (2 * GuardSize) + sizeof(integer) + 3) and
                 $7FFFFFFC;
  {get the memory}
  Result := OrigHeap.GetMem(RoundedSize);
  {providing some memory was allocated...}
  if (Result <> nil) then begin
    {save the original size at the start of the block}
    PInteger(Result)^ := Size;
    {advance the result pointer over this size value}
    inc(PChar(Result), sizeof(integer));
    {fill remainder of memory block with $CC}
    FillChar(Result^, RoundedSize - sizeof(integer), $CC);
    {return the address of the memory block in between the two guard
     blocks}
    inc(PChar(Result), GuardSize);
    {add it to our list of allocated blocks}
    AddPointer(Result);
  end;
end;
{--------}
function OurFreeMem(P : pointer) : integer;
var
  BlockSize : integer;
begin
  {the system unit's FreeMem routine will not pass a nil pointer to
   this routine, only our own clean-up routine}

  {check to see if the pointer exists in our list}
  if (P <> nil) and (not RemovePointer(P)) then begin
    {it's not a valid pointer}
    WriteLogFreeErr(HeapErrorMsg(99));
    Result := 99;
  end
  else begin
    {add the pointer to the delay queue}
    if (P <> nil) then begin
      BlockSize := PInteger(PChar(P) - GuardSize - sizeof(integer))^;
      FillChar(P^, BlockSize, $CC);
    end;
    DelayQueue[QTail] := P;
    QTail := (QTail + 1) mod DelaySize;
    {check to see whether we can actually free a pointer}
    if (QHead <> QTail) then
      Result := 0
    else begin
      {get the pointer at the head of the queue}
      P := DelayQueue[QHead];
      QHead := (QHead + 1) mod DelaySize;
      {check that the user hasn't overwritten the guard bytes}
      CheckGuardBlocks(P);
      {check that the memory block itself wasn't overwritten}
      BlockSize := PInteger(PChar(P) - GuardSize - sizeof(integer))^;
      if not aaCompareMem(P, BlockSize, $CC) then
        WriteLogOverwrite(P, 2, P, BlockSize);
      {move to the size value stored in the block: it is this pointer
       pointer that will get freed}
      dec(PChar(P), GuardSize + sizeof(integer));
      {free the memory}
      Result := OrigHeap.FreeMem(P);
      if (Result <> 0) then
        WriteLogFreeErr(HeapErrorMsg(Result));
    end;
  end;
end;
{--------}
function OurReallocMem(P : pointer; Size : integer) : pointer;
var
  OrigSize : integer;
begin
  {Note: ReallocMem has to be done with a GetMem and a FreeMem, so
   that we can maintain control of the whole process}

  {if P is nil, we merely get a new allocation if Size is non-zero}
  if (P = nil) then begin
    if (Size <= 0) then
      Result := nil
    else
      Result := OurGetMem(Size);
  end
  {otherwise, if Size is zero we free P, or if Size is non-zero we
   allocate another block, copy the contents of the current block over
   and then free the current block}
  else begin
    if (Size = 0) then
      Result := nil
    else begin
      Result := OurGetMem(Size);
      OrigSize := PInteger(PChar(P) - GuardSize - sizeof(integer))^;
      if (OrigSize < Size) then
        Move(P^, Result^, OrigSize)
      else
        Move(P^, Result^, Size);
    end;
    OurFreeMem(P);
  end;
end;
{====================================================================}


{===Initialization/finalization======================================}
procedure InitializeUnit;
var
  LogNameZ : array [0..255] of char;
begin
  {get the guard block size (must be multiple of 4 between 4 and 32)}
  GuardSize := aaReadRegistryInt('software\AlgorithmsAlfresco\AAHpDbug',
                                 'GuardSize',
                                 16);
  if (GuardSize < 4) then
    GuardSize := 4
  else if (GuardSize > 32) then
    GuardSize := 32
  else
    GuardSize := (GuardSize + 3) and $7FFFFFFC;

  {get the delay queue size (must be between 20 and 100)}
  DelaySize := aaReadRegistryInt('software\AlgorithmsAlfresco\AAHpDbug',
                                 'DelaySize',
                                 32);
  if (DelaySize < 20) then
    DelaySize := 20
  else if (DelaySize > 1000) then
    DelaySize := 100;

  {get the log name}
  aaReadRegistryString(LogNameZ, 256,
                       'software\AlgorithmsAlfresco\AAHpDbug',
                       'LogName',
                       'C:\HEAPDBUG.LOG');
  LogName := aaStrPas(LogNameZ);

  {create an array of pointers to hold the valid memory blocks}
  PtrArray := HeapAlloc(GetProcessHeap, 0, 1024 * sizeof(pointer));
  PASize := 1024;
  PACount := 0;

  {create an array to hold the delay queue for freed blocks that
   haven't been freed yet}
  DelayQueue := HeapAlloc(GetProcessHeap, 0, DelaySize * sizeof(pointer));
  QHead := 0;
  QTail := 0;

  {get the original manager}
  GetMemoryManager(OrigHeap);

  {set up our heap manager}
  OurHeap.GetMem := OurGetMem;
  OurHeap.FreeMem := OurFreeMem;
  OurHeap.ReallocMem := OurReallocMem;

  {replace heap manager with ours}
  SetMemoryManager(OurHeap);
end;
{--------}
procedure FinalizeUnit;
begin
  {free the remaining pointers in the delay queue}
  while (DelayQueue[QHead] <> nil) do
    OurFreeMem(nil);
  {report the memory leaks}
  if (PACount <> 0) then
    WriteLogLeaks;

  {restore the original manager}
  SetMemoryManager(OrigHeap);

  {free our array of pointers}
  HeapFree(GetProcessHeap, 0, PtrArray);
  {free the delay queue}
  HeapFree(GetProcessHeap, 0, DelayQueue);
end;
{====================================================================}

initialization
  InitializeUnit;

finalization
  FinalizeUnit;

end.